home *** CD-ROM | disk | FTP | other *** search
/ Nebula 1 / Nebula One.iso / Internet / WWW / Perl_WWW_Utilities / MHonArc / lib / mhtxthtml.pl < prev    next >
Encoding:
Perl Script  |  1996-01-19  |  3.2 KB  |  92 lines
  1. ##---------------------------------------------------------------------------##
  2. ##  File:
  3. ##      mhtxthtml.pl
  4. ##  Author:
  5. ##      Earl Hood       ehood@convex.com
  6. ##  Date:
  7. ##    Fri Jan 19 16:12:01 CST 1996
  8. ##  Description:
  9. ##    Library defines routine to filter text/html body parts
  10. ##    for MHonArc.
  11. ##    Filter routine can be registered with the following:
  12. ##        <MIMEFILTERS>
  13. ##        text/html:m2h_text_html'filter:mhtxthtml.pl
  14. ##        </MIMEFILTERS>
  15. ##---------------------------------------------------------------------------##
  16. ##    MHonArc -- Internet mail-to-HTML converter
  17. ##    Copyright (C) 1995    Earl Hood, ehood@convex.com
  18. ##
  19. ##    This program is free software; you can redistribute it and/or modify
  20. ##    it under the terms of the GNU General Public License as published by
  21. ##    the Free Software Foundation; either version 2 of the License, or
  22. ##    (at your option) any later version.
  23. ##
  24. ##    This program is distributed in the hope that it will be useful,
  25. ##    but WITHOUT ANY WARRANTY; without even the implied warranty of
  26. ##    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  27. ##    GNU General Public License for more details.
  28. ##
  29. ##    You should have received a copy of the GNU General Public License
  30. ##    along with this program; if not, write to the Free Software
  31. ##    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  32. ##---------------------------------------------------------------------------##
  33.  
  34.  
  35. package m2h_text_html;
  36.  
  37. $Url    = '(\w+://|\w+:)';    # Beginning of URL match expression
  38.  
  39. ##---------------------------------------------------------------------------
  40. ##    The filter must modify HTML content parts for merging into the
  41. ##    final filtered HTML messages.  Modification is needed so the
  42. ##    resulting filtered message is valid HTML.
  43. ##
  44. sub filter {
  45.     local($header, *fields, *data, $isdecode, $args) = @_;
  46.     local($base, $title, $tmp);
  47.  
  48.     ## Get/remove title
  49.     if ($data =~ s%<title\s*>([^<]*)</title\s*>%%i) {
  50.         $title = "<ADDRESS>Title: <STRONG>$1</STRONG></ADDRESS>\n";
  51.     }
  52.     ## Get/remove BASE url
  53.     if ($data =~ s%(<base\s[^>]*>)%%i) {
  54.         $tmp = $1;
  55.         ($base) = $tmp =~ m%href\s*=\s*['"]([^'"]+)['"]%i;
  56.         $base =~ s%(.*/).*%$1%;
  57.     }
  58.     ## Strip out certain elements/tags
  59.     $data =~ s%<!doctype\s[^>]*>%%i;
  60.     $data =~ s%</?html[^>]*>%%ig;
  61.     $data =~ s%</?body[^>]*>%%ig;
  62.     $data =~ s%<head\s*>[\s\S]*</head\s*>%%i;
  63.  
  64.     ## Modify relative urls to absolute using BASE
  65.     if ($base !~ /^\s*$/) {
  66.         $data =~ s%(href\s*=\s*['"])([^'"]+)(['"])%
  67.            &addbase($base,$1,$2,$3)%gei;
  68.         $data =~ s%(src\s*=\s*['"])([^'"]+)(['"])%
  69.                    &addbase($base,$1,$2,$3)%gei;
  70.     }
  71.  
  72.     ($title . $data);
  73. }
  74. ##---------------------------------------------------------------------------
  75. sub addbase {
  76.     local($b, $pre, $u, $suf) = @_;
  77.     local($ret);
  78.     $u =~ s/^\s+//;
  79.     if ($u =~ m%^$Url%o) {    # Non-relative URL, do nothing
  80.         $ret = $pre . $u . $suf;
  81.     } else {            # Relative URL
  82.     if ($u =~ m%^/%) {        # Check for "/..."
  83.         $b =~ s%^(${Url}[^/]*)/.*%$1%o;    # Get hostname:port number
  84.     }
  85.         $ret = $pre . $b . $u . $suf;
  86.     }
  87.     $ret;
  88. }
  89. ##---------------------------------------------------------------------------
  90.  
  91. 1;
  92.